perm filename MAPS2.SAI[SYS,HE]9 blob
sn#076741 filedate 1973-12-06 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00036 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 ENTRY MAPREC
C00008 00003 _ external procedures
C00010 00004 _ MAPREC - following procedures are internal - PARGR, ANGDIF
C00013 00005 _ UNCER
C00015 00006 _ UNCER cont
C00017 00007 _ RECON
C00020 00008 _ PREORB, NOASS
C00022 00009 _ LFCHCK, EXTNDV, EXTNDL
C00024 00010 _ MAKLIN, LINCHK
C00026 00011 _ PARUP
C00029 00012 _ LENCLA
C00032 00013 _ FUSE
C00034 00014 _ FUSE cont
C00036 00015 _ CLEVER, SUMMA
C00038 00016 _ DELREC
C00040 00017 _ DELREC cont
C00044 00018 _ DELREC cont
C00046 00019 _ PARCHK, PUSHDD
C00048 00020 _ CLEVA
C00051 00021 _ SCORE
C00056 00022 _ body of MAPREC begins here
C00058 00023 _ MAPREC cont - initialization and pre-orbit scan
C00060 00024 _ MAPREC cont - get and check MODIF code, attempt fusion
C00062 00025 _ MAPREC cont - start of orbiting code - test INCOVs
C00065 00026 _ MAPREC cont - Intersection seems OK. Create the new vertex and lines
C00068 00027 _ MAPREC cont - process MODIF bits and test ray
C00071 00028 _ MAPREC cont - line insertion tests and map new line
C00074 00029 _ MAPREC cont - Insert new ray and find closest collinear active line.
C00077 00030 _ MAPREC cont - insert and map full lines
C00080 00031 _ MAPREC cont - end of insertion, update tables
C00083 00032 _ MAPREC cont - test line and finish orbit, LF consistency check
C00085 00033 _ MAPREC cont - update arrays and finish this level, end of main loop
C00091 00034 _ MAPREC cont - score mapping, test for completeness, save best partial
C00094 00035 _ MAPREC cont. - finish saving partial, backup code
C00096 00036 _ MAPREC cont. - clean up scene and return
C00098 ENDMK
C⊗;
ENTRY MAPREC;
BEGIN "MAPS2"
DEFINE QC(I)="&"" I=""&CVS(I)",
QCO(I)="&"" I=""&CVOS(I)",
QCR(R)="&"" R=""&CVF(R)",
NOTHING="",
CL="'15&'12",
BL="'40",
QENP="EXTERNAL PROCEDURE",
QS="STRING",
QESP="EXTERNAL SIMPLE STRING PROCEDURE",
QI="INTEGER",
QR="REAL",
QRI="REFERENCE INTEGER",
QRR="REFERENCE REAL",
QEP="EXTERNAL SIMPLE PROCEDURE",
QEIP="EXTERNAL SIMPLE INTEGER PROCEDURE",
QERP="EXTERNAL SIMPLE REAL PROCEDURE",
QFOP="FORWARD INTERNAL SIMPLE PROCEDURE",
QFOIP="FORWARD INTERNAL SIMPLE INTEGER PROCEDURE",
QFORP="FORWARD INTERNAL SIMPLE REAL PROCEDURE",
_="COMMENT",
LOOP(I,J,K,L)="FOR I←J STEP L UNTIL K DO",
SQTRC="IF DTRACE∨MAPTRC LAND '10012000 THEN QTRCE",
QTRC="IF ¬(MAPTRC LAND '10000000)∧(DTRACE∨MAPTRC LAND '10012000)
THEN QTRCE",
SDTRC="IF DTRACE∨MAPTRC LAND '10010000 THEN DTRCE",
DTRC="IF ¬(MAPTRC LAND '10000000)∧(DTRACE∨MAPTRC LAND '10010000)
THEN DTRCE",
LINSET="DISW←1;DTRC(""LINSRT:""QC(IFREEL));LEDG1[IFREEL]←0;LINSRT",
SAFEX="",
MAPPED="1",INSERT="2",LINE="4",COLLIN="'10",UNIT="'20",
FUSED="'100",ONEND="'200",TWOND="'400",CUT="'1000",VERT="'2000",
TINCOV="2",TFUSE="1",
TSTB(LN,BT)="LEDG1[LN] LAND (BT)",
SETB(LN,BT)="LEDG1[LN] ← LEDG1[LN] LOR (BT)",
RESET(LN,BT)="LEDG1[LN] ← LEDG1[LN] LAND LNOT(BT)";
EXTERNAL INTEGER PROT,PLIN,PVER,AD0,LNCS1,LNCS2,RAYS,CMPIND,DTRACE,
MDCTR,DISW,LFDBT,DEGSW,DEGABL,LNCRE0,IFREEL,IFREEV,MAXNOL,
FULREC,LNCRE1,LNCRE2,FTREV,MODIF,MAXPLS,MAPTRC,FTSW;
EXTERNAL REAL RWIC,RMALS,RELLF,RMAP;
SAFEX EXTERNAL INTEGER ARRAY LEDG1,LEDG2,LCREDE,LFEAT,LVERCO,LINK,
PLINE,PLINEF[1:1];
_ external procedures;
SAFEX EXTERNAL REAL ARRAY XVCOR,YVCOR,XLCOR,YLCOR,RLEN,ANGARG[1:1];
INTERNAL INTEGER SCO, CONF, CMPL;
SAFEX REAL ARRAY RRR,RNUM[0:1];
SAFEX INTEGER ARRAY LFUSES[1:63];
SAFEX EXTERNAL STRING ARRAY PNAME[1:1];
QEIP NLINCV(QI I);
QERP AMOD(QR R,S);
QEIP LESSFT(QI I,J);
QEIP BITS(QI I,J,K);
QEIP NEXTSV(QI I,J);
QEIP INREK(QR X,Y);
QEIP ISIGN(QI I,J);
QERP ANGLIN(QI I,J);
QEIP LVOPP(QI I);
QERP LDIST(QR X,Y; QI I);
QEIP KARN(QR X1,Y1,X2,Y2,X3,Y3,X4,Y4; QI IC);
QEP REKOP(QR X1,Y1,X2,Y2,WI; QRR RL);
QEIP LNFEAT(QI I);
QEP MALI(QI I; QR X1,Y1,X2,Y2);
QERP SIGN(;QR R,S);
QEP WEIGHV(QI I; QRR X,Y,WE);
QEIP LINSRT(QI I,J; QR X1,Y1,X2,Y2; QI K,L);
QEIP LCRV(QI I);
QEIP LCRL(QI L);
QEP DTRCE(QS S);
QEP LINDL(QI L,I);
QEP QTRCE(QS S);
QEP MLCR(QI I,J);
QEP REVIVE(QI L);
QEP UPPDAL(QI I);
QEIP FUSABL(QI I,J,K,L);
QEIP LFDIF(QI I,J,K,L,T);
QEIP LVNEXT(QI I,J);
QEIP CONDIV(QI A);
_ MAPREC - following procedures are internal - PARGR, ANGDIF;
_ Builds up mapping as far as it can, in explicitly programmed recursion;
INTERNAL INTEGER PROCEDURE MAPREC;
BEGIN "MAPREC"
LABEL RULS,BU,OU,OU0,BA0,BA1,BA2,ON1,MO,MO1,L1,L2,L4,FUS,L3,
NFUS,NINC,BAAU;
INTEGER IA,IB,ID,IC,IG,RAYCNT,IFR,BAUS,IBB,ICV0,RLEV,LMAP,V1,V2,NSV,
IRET,BAU,NVP,NVSC,VEMOD,MAPI,MPORD,IDL,INCOV,INCOVS,RAY,
ICN,BULEVS,IAA,LNY,VL,INSUF,CH,INS,MOBITS,PLND,NDSCM,CONH,
NLSCM,NDP,NDSC,NEWLP,NEWSV,NEWLSC,NL1,NL2,VPR,VSC,RUL,N1,N2;
REAL WE,GA,DA,X1,Y1,X2,Y2,RDIF,RP,RL;
SAFEX EXTERNAL REAL ARRAY LENARG[0:MAXPLS,0:1,0:1],PARARG[0:MAXPLS];
SAFEX EXTERNAL INTEGER ARRAY MPORDS,MAPIS[1:2*MAXPLS],
LFUSE[1:MAXPLS,0:1],EVA[1:MAXPLS],PVMAP,VLEV,MAPORD,PARCLA,
DEADLN,LENCAT,INSLEV,LFTSTL[1:1],LENDV,LENDP,PLMAP,PLMAPO,
LLEV,LLEVO[1:1,0:1],PARTS[1:63,0:1+MAXPLS%3];
FORWARD SIMPLE INTEGER PROCEDURE LENCLA(INTEGER PL,SVL,SV,ITRS);
EXTERNAL INTEGER IP1, IP2;
EXTERNAL REAL R1, R2, X, Y;
BOOLEAN PROGRESS;
_ Returns line // PBL, and in a pointer-relation to OTH (ie. //-gram).;
SIMPLE INTEGER PROCEDURE PARGR(INTEGER PBL,OTH);
BEGIN "PARGR"
INTEGER IA;
LOOP(IA,1,PLIN,1)
IF IA≠PBL
∧PARCLA[IA]=PARCLA[PBL]
∧(LENDP[OTH,0]=IA
∨LENDP[OTH,1]=IA
∨LENDP[IA,0]=OTH
∨LENDP[IA,1]=OTH)
THEN RETURN(IA);
RETURN(0)
END "PARGR";
_ return the least difference of angles a1 and a2 (directions ignored);
SIMPLE REAL PROCEDURE ANGDIF(REAL A1,A2);
RETURN(ABS(AMOD(ABS(A1-A2)+90.,180.)-90.));
_ UNCER;
_ Replaces intersection (if necessary and possible) so as to
satisfy LENCLA. Returns 0 for OK, -1 otherwise.;
SIMPLE INTEGER PROCEDURE UNCER;
BEGIN "UNCER"
INTEGER IND,I,IO,PL,CV,IL,I1,I2;
REAL RA,RB,RC,RD,A1,A2,RD1,RD2,AD1,AD2,RP1,RP2;
SIMPLE PROCEDURE SET1;
BEGIN
X←X2+(X-X2)*RB/RD;
Y←Y2+(Y-Y2)*RB/RD;
END;
SIMPLE PROCEDURE SET2;
BEGIN
X←X1+(X-X1)*RA/RC;
Y←Y1+(Y-Y1)*RA/RC;
END;
IND←-2;
CV←LVERCO[IC];
X1←XVCOR[CV];
Y1←YVCOR[CV];
MALI(IFREEL,X,Y,X1,Y1);
IO←LENCLA(IA,-IFREEL,0,0);
RP1←RP;
RD1←RDIF;
RC←RLEN[IFREEL];
RA←RC-(IF IO=1∨IO=-2 THEN RDIF+SIGN(1.,RDIF) ELSE 0.);
PL←NEWLP;
CV←PVMAP[NVP];
X2←XVCOR[CV];
Y2←YVCOR[CV];
MALI(IFREEL,X,Y,X2,Y2);
I←LENCLA(PL,-IFREEL,0,0);
IF IO≠-2∧IO≠1∧I≠-2∧I≠1 THEN RETURN(0);
RP2←RP;
RD2←RDIF;
RD←RLEN[IFREEL];
RB←RD-(IF I=1∨I=-2 THEN RDIF+SIGN(1.,RDIF) ELSE 0.);
IF ¬IO∧(I=1∨I=-2) THEN BEGIN SET1; RETURN(0); END;
IF ¬I∧(IO=1∨IO=-2) THEN BEGIN SET2; RETURN(0); END;
_ UNCER cont;
A1←PARARG[PARCLA[IA]];
A2←PARARG[PARCLA[NEWLP]];
AD1←ANGDIF(ANGARG[NLSCM],A1);
AD2←ANGDIF(ANGARG[(IG+1)%2],A2);
IF ABS(AD1-AD2)<3. THEN
BEGIN
IL←ABS(RLEN[NLSCM]/RP1-1.)<ABS(RLEN[(IG+1)%2]/RP2-1.);
RA←0.5*(RP1+RA);
SET2;
END ELSE BEGIN
IL←AD1<AD2;
RB←0.5*(RP2+RB);
PL←IA;
SET1;
END;
MALI(IFREEL,X,Y,IF IL THEN X2 ELSE X1,IF IL THEN Y2 ELSE Y1);
I←LENCLA(PL,-IFREEL,0,0);
IF I=-1∨¬I THEN RETURN(0);
V1←PARGR(IA,NEWLP);
V2←PARGR(NEWLP,IA);
IF V1∧V2 THEN
BEGIN
I1←PLMAP[V1,0];
I2←PLMAP[V2,0];
IF 0<I1<'7777∧0<I2<'7777 THEN
BEGIN
A1←ANGARG[(I1+1)%2];
A2←ANGARG[(I2+1)%2]
END;
END;
I←KARN(X1
,Y1
,X1+10.*COSD(A1)
,Y1+10.*SIND(A1)
,X2
,Y2
,X2+10.*COSD(A2)
,Y2+10.*SIND(A2)
,1);
RETURN(I≠1)
END "UNCER";
_ RECON;
_ Finds the (reconciliated) MODIF word for the current base-line.
If ¬RUL, returns the MODIF from first LFDIF call.
Otherwise searches the vertex for full lines, returning the
base-line adjusted first unambiguous MODIF, if any (otherwise
returns the first MODIF).;
SIMPLE PROCEDURE RECON;
BEGIN "RECON"
LABEL BA1,ON1;
INTEGER MOD1,CTR,SRAYS,MEWSV,MEWLP,MDP,MEWLSC,MDSC,MBTS,
DL,DI,DD,MSH,MDF,FRST;
FRST←MOD1←CTR←0;
MEWLP←NEWLP;
MDP←NDP;
MEWLSC←NEWLSC;
MDSC←NDSC;
BA1: LFDIF(PLINEF[AD0+MEWLP],LNFEAT(MEWLSC),MDP,
IF FTREV=1 THEN 1-MDSC ELSE MDSC,FRST);
FRST ← TRUE;
IF ¬RUL∨¬MOD1∧MODIF≠-1∧MODIF LAND '200000000000 THEN RETURN;
IF ¬MOD1 THEN BEGIN MOD1←MODIF; SRAYS←RAYS END;
IF MODIF LAND '600000000000 THEN GO ON1;
IF ¬CTR THEN RETURN;
DL←DI←DD←0;
MSH←-2;
MDF←MODIF LSH (2-MDCTR);
WHILE DL+DI<CTR DO
BEGIN
MSH←MSH+2;
CASE (MBTS←(MDF←MDF LSH -2) LAND 3) OF
BEGIN DL←DL+1; DI←DI+1; DD←DD+1 END
END;
IF MBTS∨NEXTSV(NEWSV,DD+DL)≠MEWSV THEN GO ON1;
MODIF←MODIF LSH (34-MSH-MDCTR) LOR (MDF LSH -2) LSH MDCTR;
RAYS←SRAYS;
RETURN;
ON1: IF(MEWLP←LENDP[MEWLP,MDP])=NEWLP THEN
BEGIN MODIF←MOD1; RAYS←SRAYS; RETURN END;
CTR←CTR+1;
MDP←-(LENDV[MEWLP,0]≠VPR);
MEWSV←PLMAP[MEWLP,1-MDP];
IF MEWSV∧MEWSV≠'7777∧LVERCO[MEWSV←LVOPP(MEWSV)]=VSC THEN
BEGIN
MEWLSC←(MEWSV+1)%2;
MDSC←1-(MEWSV LAND 1);
GO BA1
END ELSE GO ON1
END "RECON";
_ PREORB, NOASS;
_ Returns 0 if all of the mapped lines of the present vertex are assumed
rays or unmapped at the other end, or INCOVS is on., -2 if at least one
of them is flagged at the junction with the present vertex as backing,
-1 if there is at least one full line;
SIMPLE INTEGER PROCEDURE PREORB;
BEGIN "PREORB"
INTEGER MEWLP,MDP,PLM,IRET;
IF INCOVS THEN RETURN(0);
MEWLP←NEWLP;
MDP←NDP;
IRET←0;
WHILE (MEWLP←LENDP[MEWLP,MDP])≠NEWLP DO
BEGIN
MDP←-(LENDV[MEWLP,0]≠VPR);
PLM←PLMAP[MEWLP,1-MDP];
IF PLM∧PLM≠'7777∧LVERCO[LVOPP(PLM)]=VSC THEN
BEGIN
PLM←LLEV[MEWLP,MDP]<0;
IF PLM∨¬IRET THEN IRET←-1+PLM;
END;
END;
RETURN(IRET)
END "PREORB";
_ Returns 1 (else 0) iff there are no assumed rays hanging on to
current prototype line, IAA.;
SIMPLE INTEGER PROCEDURE NOASS;
BEGIN "NOASS"
INTEGER RAY,IB,IE;
LOOP(IB,0,1,1)
BEGIN
IE←IB;
RAY←IAA;
WHILE (RAY←LENDP[RAY,IE])≠IAA DO
BEGIN
IE←-(LENDV[RAY,0]≠LENDV[IAA,IB]);
IF PLMAP[RAY,IE]='7777 THEN RETURN(0)
END
END;
RETURN(1)
END "NOASS";
_ LFCHCK, EXTNDV, EXTNDL;
_ Returns -1 iff s.v. ISV or line IL has a connected extension to an
unused line and passes through a vertex of ≤ 3 lines;
SIMPLE INTEGER PROCEDURE EXTNDV(INTEGER ISV);
BEGIN
INTEGER ISVO,CV;
ISVO ← LINK[ISV];
CV ← LVERCO[ISV];
RETURN(ISVO>0∧LCRV(ISVO)<1001∧CV=LVERCO[ISVO]∧NLINCV(CV)≤3);
END;
SIMPLE INTEGER PROCEDURE EXTNDL(INTEGER IL);
RETURN(EXTNDV(2*IL)∨EXTNDV(2*IL-1));
_ Returns 1 (else 0) iff untested complete lines are l.f.-consistent.;
SIMPLE INTEGER PROCEDURE LFCHCK;
BEGIN "LFCHCK"
INTEGER ISV,IRET,IND;
LNCRE1←1001;
IRET←0;
LOOP(IAA,1,PLIN,1) IF INSLEV[IAA]∧¬LFTSTL[IAA]∧NOASS THEN
BEGIN
ISV←PLMAP[IAA,1];
IND←ISV LAND 1;
IF LESSFT(PLINEF[AD0+IAA],LNFEAT((ISV+1)%2))
∨IND∧FTREV=2
∨ ¬IND∧FTREV=1
THEN IRET←IAA ELSE LFTSTL[IAA]←RLEV;
END;
LNCRE1←LNCS1;
DTRC("LFCHCK:"QC(IRET));
RETURN(¬IRET)
END "LFCHCK";
_ MAKLIN, LINCHK;
_ Make a new line for INCOVS;
SIMPLE PROCEDURE MAKLIN(INTEGER NEWLSC,IA,IB,IC,V2;REAL X,Y;INTEGER PLND);
BEGIN
INTEGER V,V1;
MLCR(NEWLSC,1003);
PLMAPO[IA,1-IB]←IC;
PLMAP[IA,IB]←2*IFREEL;
PLMAP[IA,1-IB]←2*IFREEL-1;
IFR←IFREEL;
V1 ← IF V2 THEN V2 ELSE IFREEV;
LINSET(ICV0,V2,XVCOR[ICV0],YVCOR[ICV0],X,Y,1002,0);
RL←SQRT((XLCOR[PLND]-XVCOR[ICV0])↑2+(YLCOR[PLND]-YVCOR[ICV0])↑2);
V ← LEDG1[NEWLSC];
SETB(IFR,"MAPPED+INSERT+LINE+
(IF EXTNDV(IC)∨RLEN[IFR]-RL+RMALS<0. THEN CUT ELSE 0)+
(IF (¬(V LAND INSERT)∨(V LAND COLLIN))
∧FUSABL(IC,0,V1,0) THEN COLLIN ELSE 0)+
(IF ¬(V LAND INSERT)∨(V LAND ONEND) THEN ONEND ELSE 0)");
PLMAPO[IA,IB]←0;
DTRC("MAKLIN :"QCO(LEDG1[IFR]));
END;
_ Common updating for line mappings;
SIMPLE PROCEDURE LINCHK(INTEGER NEWLSC);
BEGIN "LINCHK"
INTEGER I;
I ← LEDG1[NEWLSC];
LEDG1[NEWLSC]←I←I LAND LNOT(UNIT+FUSED) LOR LINE;
IF ¬INCOVS THEN
BEGIN
LEDG1[NEWLSC]←I LOR (IF I LAND ONEND THEN TWOND ELSE ONEND);
IF I LAND ONEND THEN RESET(NEWLSC,ONEND);
END;
IF ¬INSLEV[NEWLP] THEN IG←INSLEV[NEWLP]←-RLEV;
END "LINCHK";
_ PARUP;
_ Updates mean angular argument for parallelity class of prototype
line PL, weighting complete lines as two rays, except when created
by an INCOV;
SIMPLE PROCEDURE PARUP(INTEGER PL);
BEGIN "PARUP"
INTEGER IA,IB,IC,PARCL,CODIV;
REAL AVANG,NUM,D,B;
N1←LENCAT[PL];
NUM←AVANG←RRR[0]←RRR[1]←RNUM[0]←RNUM[1]←0.;
PARCL←PARCLA[PL];
IF PARCL THEN
LOOP(IA,1,PLIN,1)
IF PARCLA[IA]=PARCL THEN
LOOP(IB,0,1,1)
BEGIN
IC←PLMAP[IA,IB];
IF IC∧IC≠'7777∧ABS LLEV[IA,IB]≠ABS LLEV[IA,1-IB] THEN
BEGIN
B←AMOD(ANGARG[(IC+1)%2],180.);
D←B-AVANG;
AVANG ← AMOD(180.+(NUM*AVANG+
(IF ABS(D)>90. THEN B-SIGN(180.,D) ELSE B))
/(NUM←NUM+1.)
,180.);
NL1←PVMAP[LENDV[IA,0]];
NL2←PVMAP[LENDV[IA,1]];
IF IB∧NL1∧NL2∧N1=LENCAT[IA] THEN
BEGIN
CODIV←CONDIV(IA+AD0);
RRR[CODIV]←RRR[CODIV]+
SQRT((XVCOR[NL1]-XVCOR[NL2])↑2+
(YVCOR[NL1]-YVCOR[NL2])↑2);
RNUM[CODIV]←RNUM[CODIV]+1.;
END
END;
END;
PARARG[PARCL]←IF NUM THEN AVANG ELSE -1.;
LOOP(IA,0,1,1) RRR[IA]←RRR[IA]/(RNUM[IA] MAX 1.);
LOOP(IA,0,1,1)
BEGIN
IF ¬RRR[IA] THEN RRR[IA]←RRR[1-IA];
LENARG[PARCL,IA,N1]←RRR[IA];
END;
DTRC("PARUP: "QC(PL)QC(PARCL)QCR(NUM)QCR(AVANG)
QCR(RNUM[0])QCR(RNUM[1])QCR(RRR[0])QCR(RRR[1]));
END "PARUP";
_ LENCLA;
_ Returns the following, depending on the relative size of line SVL
using CV coords if SVL>0, RLEN otherwise (for UNCER)
(if SV=0), or distance between the c.v:s of SVL and SV (if SV>0),
to length-class of PL:
-2 iff the line is too short.
-1 iff the line is acceptable.
0 iff there is no comparison, or no length-class.
1 iff the line is too long.
The program allows ITRS iterations, each time adjusting the length
by a factor RELLF, depending on perspective clues. [CONSTANT-KKP];
SIMPLE INTEGER PROCEDURE LENCLA(INTEGER PL,SVL,SV,ITRS);
BEGIN "LENCLA"
LABEL OU,ITR;
INTEGER IRET,LCL,CODIV,N1,N2;
REAL RSC,ML;
IRET←0;
RSC←RP←0.;
ML←1.+RELLF;
LCL←PARCLA[PL];
IF ¬LCL THEN GO OU;
IF SV THEN BEGIN N1←ABS SVL; N2←SV END ELSE
BEGIN N2←2*(ABS SVL); N1←N2-1; END;
N1←LVERCO[N1];
N2←LVERCO[N2];
RSC←IF SVL≥0 THEN SQRT((XVCOR[N1]-XVCOR[N2])↑2+
(YVCOR[N1]-YVCOR[N2])↑2) ELSE RLEN[ABS SVL];
CODIV←CONDIV(PL+AD0);
RP←LENARG[LCL,CODIV,LENCAT[PL]];
IF ¬RP THEN GO OU;
ITR: RDIF←RSC-ML*RP;
IRET←IF RDIF>0. THEN 1 ELSE
IF (RDIF←RSC-RP/ML)<0. THEN -2 ELSE -1;
IF ITRS∧(IRET=-2∧¬CODIV∨IRET*CODIV=1) THEN
BEGIN
ITRS←ITRS-1;
IRET←0;
ML←ML*(1.+RELLF);
GO ITR
END;
OU: IF ¬IRET∨IRET=-1 THEN RDIF←RSC-RP;
DTRC("LENCLA:"QC(PL)QC(SVL)QC(SV)QC(LCL)QC(CODIV)QCR(RSC)
QCR(RP)QCR(RDIF)QC(ITRS)QC(IRET));
RETURN(IRET)
END "LENCLA";
_ FUSE;
_ If possible fuses current scene-line and returns 1, else returns 0.
Treats pos. and neg. links alike.;
SIMPLE INTEGER PROCEDURE FUSE(INTEGER IC,IA,IB);
BEGIN "FUSE"
INTEGER N1,ICO,I1,I2,IL,ICV,TEST,B;
IAA←0;
ICO←LVOPP(IC);
IDL←ABS LINK[ICO];
IF IDL THEN
BEGIN
N1←LVOPP(IDL);
IAA←LENCLA(IA,IC,N1,1);
V2←(IC+1)%2;
V1←(IDL+1)%2;
DA←ANGLIN(V2,V1);
END;
DTRC("FUSE: "QC(IC)QC(IA)QC(IB)QC(IDL)QCR(DA));
IF ¬IDL∨LCRV(IDL)>1000∨IAA=1∨DA>RMAP THEN
BEGIN
LEDG2[IA] ← LEDG2[IA] LOR TFUSE;
RETURN(0);
END;
ICV←LVERCO[IC];
_ There is a possible fusion. Check for possible INCOV between
end of line to be fused.;
I1←IA;
I2←IB;
WHILE (I1←LENDP[I1,I2])≠IA DO
BEGIN
I2←-(LENDV[IA,IB]≠LENDV[I1,0]);
IL←(PLMAP[I1,1-I2]+1)%2;
IF IL∧IL≠'4000∧¬TSTB(IL,UNIT)∧TSTB(IL,ONEND+TWOND)
∧LDIST(XVCOR[VSC],YVCOR[VSC],IL)
/LDIST(XVCOR[ICV],YVCOR[ICV],IL)<-2.*RELLF THEN
BEGIN DTRC("INCOV-pass");RETURN(0) END
END;
_ There is a link to an unused line. Fuse the lines, i.e.
insert a compound line.;
I1←LVERCO[ICO];
I2←LVERCO[IDL];
ICO ← NLINCV(I1);
B ← LEDG1[V2];
_ FUSE cont;
TEST ← (LCRL(V2)=1002∧(B LAND VERT))
∨(I1≠I2∧(ICO≥3∨NLINCV(I2)≥3))
∨(I1=I2∧ICO≥4);
_ Pointers and I.D.s fixed up by calling program!! ;
VSC←LVERCO[N1];
MLCR(V1,1003);
MLCR(V2,1003);
QTRC(CL&"Fusion: "&CVS(V2)&" + "&CVS(V1)&" → "&CVS(IFREEL));
NEWLSC←IFREEL;
NEWSV←2*NEWLSC;
PLMAP[IA,1-IB]←NEWSV-1;
LINSET(ICV,VSC,XLCOR[IC],YLCOR[IC],XLCOR[N1],YLCOR[N1],1002,0);
SETB(NEWLSC,"MAPPED+INSERT+FUSED+
(IF ¬(B LAND INSERT)∨(B LAND COLLIN) THEN COLLIN ELSE 0)+
(IF ¬(B LAND INSERT)∨(B LAND ONEND) THEN ONEND ELSE 0)+
(IF TEST THEN VERT ELSE 0)");
LOOP(IG,1,63,1) IF ¬LFUSES[IG] THEN
BEGIN
_ First unused LFUSES-word. Store here.;
LFUSES[IG]←IC LSH 12 LOR (NEWSV-1);
DONE
END;
IF LINK[NEWSV]←LINK[N1] THEN LINK[ABS LINK[N1]]←NEWSV;
LFUSE[IA,IB]←LFUSE[IA,IB] LSH 6 LOR IG;
NDP←1;
IF MAPTRC LAND 1 THEN UPPDAL(MAPTRC LAND 2);
DTRC(" "QCO(LEDG1[NEWLSC]));
RETURN(1)
END "FUSE";
_ CLEVER, SUMMA;
_ If SW=0, inactivates unused scene-lines at vertex ICV (LCREDE←ILCR).
If SW=1, Revives inactivated (LCREDE=ILCR) lines at vertex ICV.;
SIMPLE PROCEDURE CLEVER(INTEGER ICV,ILCR,SW);
BEGIN "CLEVER"
IF SW THEN LNCRE1←LNCRE2←ILCR ELSE LNCRE2←1000;
ICV0←LVNEXT(ICV,9);
WHILE ICV0 DO
BEGIN
IF SW THEN REVIVE((ICV0+1)%2) ELSE MLCR((ICV0+1)%2,ILCR);
ICV0←LVNEXT(0,9)
END;
LNCRE1←LNCS1;
LNCRE2←1002
END "CLEVER";
_ Computes the number of mapped elements with characteristics as
described by the mask.;
SIMPLE INTEGER PROCEDURE SUMMA(INTEGER MSK);
BEGIN "SUMMA" INTEGER IA,IB;
START_CODE LABEL L1;
MOVE 2,EVA;
SETZM 1;
MOVE 3,PLIN;
MOVE 4,-1('17);
L1: MOVE 5,(2);
AND 5,4;
CAMN 5,4;
ADDI 1,1;
ADDI 2,1;
SOJG 3,L1;
MOVEM 1,IB;
END;
IF IB THEN SDTRC("SUMMA: "QCO(MSK)QC(IB));
RETURN(IB)
END "SUMMA";
_ DELREC;
_ Deletes results at present recursion level. Update ||-class data if SW;
SIMPLE INTEGER PROCEDURE DELREC(INTEGER SW);
BEGIN "DELREC"
LABEL BA1;
BOOLEAN INCFLG;
INTEGER IA,IB,IC,LID,IAS,VF,LEV,RLB,BASL,INSLS,VL;
DTRC("DELREC: "QC(RLEV)QC(SW)QC(BULEVS));
BA1: MPORD←MPORDS[RLEV]+1;
INCFLG←IAS←RLB←0;
IF RLEV<3 THEN RETURN(1);
LOOP(IA,1,PVER,1) IF ABS VLEV[IA] =RLEV THEN
BEGIN
IF VLEV[IA]<0 THEN INCFLG←IA;
CLEVER(PVMAP[IA],1007,1);
PVMAP[IA]←VLEV[IA]←0;
DONE
END;
LOOP(IA,1,PLIN,1) IF DEADLN[IA]=RLEV THEN DEADLN[IA]←-1;
LOOP(IA,1,PLIN,1)
LOOP(IB,0,1,1)
BEGIN "DELA"
LEV←LLEV[IA,IB];
IF ABS(LEV)=RLEV
∧(LEV>0∨¬TSTB("(PLMAP[IA,1-IB]+1)%2",UNIT)) THEN
BEGIN "DELB"
LID←(PLMAP[IA,IB]+1)%2;
VF←LFUSE[IA,IB];
PLMAP[IA,IB]←LLEV[IA,IB]←0;
IF LID∧LID≠'4000∧TSTB(LID,UNIT) THEN
BEGIN
_ delete inserted ray;
DTRC("DEL. INS. RAY"QC(IA));
LINK[2*LID]←LLEV[IA,1-IB]←0;
LINDL(LID,0);
DONE
END;
INSLS←INSLEV[IA];
IF INSLS>0 THEN
BEGIN "DELC"
_ delete new insertion;
PLMAP[IA,1-IB]←PLMAPO[IA,1-IB];
IC←(PLMAP[IA,1-IB]+1)%2;
IF IC∧IC≠'4000 THEN REVIVE(IC);
_ DELREC cont;
IC←PLMAPO[IA,IB];
IF IC∧IC≠'7777 THEN REVIVE((IC+1)%2);
LLEV[IA,IB]←LLEVO[IA,IB];
IF LID∧LID≠'4000 THEN LINDL(LID,0)
END "DELC" ELSE
IF LID∧LID≠'4000∧¬INSLS∧¬VF∧LEV>0 THEN
REVIVE(LID);
LFTSTL[IA]←INSLEV[IA]←0;
IF INCFLG THEN LEDG2[IA] ← LEDG2[IA] LOR TINCOV;
IF LEDG2[IA]=TINCOV+TFUSE∧¬DEADLN[IA] THEN
BEGIN "DEDX"
DEADLN[IA] ← -1;
DTRC("KILL RAY "QC(IA))
END "DEDX";
IF LEV<0 THEN
IF ¬VF THEN
IF ¬BULEVS∧¬FULREC THEN
BEGIN "DELD"
RLEV←RLEV-1;
DTRC("NEG RAY"QC(IA)&" BU TO"QC(RLEV));
GO BA1
END "DELD" ELSE NOTHING ELSE DO BEGIN "DELF"
_ We have the case of a compound line.
Unfuse last step - restore
constituents.
If BULEVS>0, back up all fuses;
V1←VF LAND '77;
VF←LFUSE[IA,IB]←LFUSE[IA,IB] LSH -6;
V2←LFUSES[V1] LAND '7777;
IC←PLMAP[IA,1-IB]←LFUSES[V1] LSH -12;
LFUSES[V1]←0;
IDL←ABS LINK[LVOPP(IC)];
V1←LVOPP(IDL);
IG←LINK[V1];
IF IG THEN
BEGIN
LINK[ABS IG]←ISIGN(V1,IG);
LINK[LVOPP(V2)]←0;
END;
IC←(IC+1)%2;
REVIVE(IC);
IDL←(IDL+1)%2;
REVIVE(IDL);
V2←(V2+1)%2;
LINDL(V2,0);
QTRC(CL&"Un-fusion: "&CVS(V2)&" → "&
CVS(IC)&" + "&CVS(IDL)&
" Same"QC(RLEV));
_ DELREC cont;
IF ¬BULEVS THEN
BEGIN
LLEV[IA,IB]←LEV;
RLB←1;
MAPIS[RLEV]←MAPIS[RLEV-1];
DONE;
END;
END "DELF" UNTIL ¬VF ELSE BEGIN "DELG"
_ delete a complete line, remember if base;
IC←MPORDS[LEV];
BASL←IC∧MAPORD[IC]=IA;
IF BASL THEN IAS←IA ELSE
IF INSLS<0 THEN LLEV[IA,IB]
←LLEVO[IA,IB];
END "DELG";
IF SW THEN PARUP(IA);
DONE
END "DELB";
END "DELA";
_ If two lines backed up not flagged already backing, flag current
line as backing for main loop. Otherwise, delete INCOV;
IF ¬BULEVS∧SW THEN IF INCFLG THEN
BEGIN
SW ← 1;
RLEV←RLEV-1;
DTRC("VERTEX "QC(INCFLG)&"-BU TO "QC(RLEV));
GO BA1
END ELSE IF IAS THEN BEGIN
MPORD←MPORD-1;
BAUS←1;
END;
IF RLB THEN RLEV←RLEV+1;
MAPI←MAPIS[RLEV-1];
IF MAPTRC LAND 1 THEN UPPDAL(MAPTRC LAND 2);
RETURN(0)
END "DELREC";
_ PARCHK, PUSHDD;
_ Returns 1 (else 0) iff the current mapping is an acceptable partial.;
SIMPLE INTEGER PROCEDURE PARCHK;
BEGIN "PARCHK"
INTEGER IA,IB,IC,IAA,N1;
_ Check for incovs.;
LOOP(IA,1,PVER,1)
IF ¬PVMAP[IA] THEN
BEGIN
IAA←-1;
LOOP(IB,1,PLIN,1)
LOOP(IC,0,1,1)
IF LENDV[IB,IC]=IA THEN
BEGIN
N1←PLMAP[IB,1-IC];
IF N1∧N1≠'7777 THEN
BEGIN
IAA←IAA+1;
IF IAA THEN RETURN(0)
END;
END;
END;
_ Check for fused rays.;
LOOP(IB,1,PLIN,1)
LOOP(IC,0,1,1)
IF ¬PLMAP[IB,IC] THEN
BEGIN
IAA←PLMAP[IB,1-IC];
IA←(IAA+1)%2;
IF IA∧IA≠'4000∧LCRL(IA)=1002∧¬TSTB(IA,UNIT)∧
NLINCV(LVERCO[LVOPP(IAA)])>1 THEN RETURN(0);
END;
RETURN(1)
END "PARCHK";
SIMPLE PROCEDURE PUSHDD;
BEGIN
INTEGER IA;
LOOP(IA,1,PLIN,1) IF DEADLN[IA]=-1 THEN DEADLN[IA] ← RLEV;
END;
_ CLEVA;
_ Sets classification bits for prototype line PL.;
SIMPLE PROCEDURE CLEVA;
BEGIN "CLEVA"
INTEGER B, PLN, PEND, SLN, BT;
LOOP(PLN,1,PLIN,1)
BEGIN "PLINES"
B ← IF PLINE[AD0+PLN] LAND '6000 THEN '10 ELSE '20;
LOOP(PEND,0,1,1)
BEGIN "PENDS"
SLN←(PLMAP[PLN,PEND]+1)%2;
IF SLN THEN IF SLN='4000 THEN
BEGIN "TOKEN"
B ← B+'12244205;
DONE;
END "TOKEN" ELSE BEGIN "ACTUAL"
BT ← LEDG1[SLN];
IF ¬(BT LAND LINE) THEN
BEGIN "RAY"
IF BT LAND UNIT THEN BEGIN B←B+'12241205; DONE; END;
B ← B+(IF BT LAND FUSED THEN '2205 ELSE '205);
END "RAY" ELSE B←B+(IF LFTSTL[PLN] THEN '103 ELSE '105);
B ← B+(IF BT LAND CUT∨(BT LAND INSERT∧EXTNDL(SLN))
THEN '100000 ELSE '200000);
IF BT LAND INSERT THEN
BEGIN "INSERT"
B ← B+(IF BT LAND COLLIN THEN '20000 ELSE '40000)
+(IF BT LAND VERT THEN '1000000 ELSE '2000000);
IF ¬(BT LAND (ONEND+TWOND)) THEN
BEGIN B←B+'10000000;DONE;END;
END "INSERT" ELSE B←B+'2010000;
B ← B+(IF BT LAND ONEND THEN '20000000 ELSE '40000000);
DONE;
END "ACTUAL";
END "PENDS";
EVA[PLN]←B;
SDTRC("CLEVA: "QCO(EVA[PLN])QC(PLN)QC(SLN));
END "PLINES";
END "CLEVA";
_ SCORE;
_ Computes score for a mapping. Also determines whether it is
sufficient and (if so) whether it is complete.;
SIMPLE PROCEDURE SCORE;
BEGIN "SCORE"
INTEGER NB,TOT,NI;
_ check for sufficiency;
CONF←INSUF←CMPL←SCO←0;
TOT ← SUMMA(1);
IF TOT<3∨SUMMA('40010001)<2
THEN BEGIN INSUF←1; RETURN END;
_ Sufficient, calculate score;
SCO← + 8 * (SUMMA('42210001)+SUMMA('42220001))
+ 6 * (SUMMA('22210105)+SUMMA('22220105)+SUMMA('22200103))
+ 4 * SUMMA('12200003)
+ 2 * (SUMMA('22210201)+SUMMA('22220201))
- SUMMA('40105)
- 2 * SUMMA('40201)
- 2 * SUMMA('20000010)
- 3 * SUMMA('10000010)
- 4 * SUMMA('1000001)
- 5 * SUMMA('40211)
- 6 * SUMMA('100001);
IF SCO<0 THEN SCO ← 0;
CONF ← SCO*12.5/PLIN;
_ check for complete parse;
NB ← SUMMA('10);
NI ← SUMMA('20);
CMPL ← SUMMA(3)=PLIN
∧ ¬(SUMMA('1000000)+SUMMA('100000))
∧ ¬SUMMA('40011)
∧ ¬(SUMMA('20000010)+SUMMA('10000010))
∧ SUMMA('20000011)≤(IF PLIN<5 THEN 1 ELSE 2)
∧ (SUMMA('10000021)+SUMMA('40021)-SUMMA('10040021))≤(NI+2)%3
∧ SUMMA('20000021)≤(NI+1)%2;
SDTRC("SCORE:"QC(SCO)QC(CMPL)QC(CONF));
END "SCORE";
_ body of MAPREC begins here;
MAPI←MPORD←1;
RUL←BULEVS←BAU←BAUS←CMPL←CONH←0;
IRET←-1;
PROGRESS ← FALSE;
LNCRE0←1001;
LNCRE2←1002;
RLEV←2;
DEGSW←IF PROT≤2∧DEGABL THEN 2 ELSE 0;
QTRC(CL&"F-mappings"&CL);
IF MAPTRC LAND 1 THEN UPPDAL(MAPTRC LAND 2);
_ Find mappings according to current rule (F=0 or C=1) for all
unmapped end-vertices of previously mapped lines.;
_ * * * * * CENTRAL LOOP BEGINS * * * * *;
_ Find an unmapped vertex or a mapped prototype line whose SV was
not mapped at the last level;
RULS: LOOP(ID,MPORD,MAPI,1) IF DEADLN[MAPORD[ID]]≠-1 THEN LOOP(IBB,0,1,1)
BEGIN "A"
IB←IBB XOR LFDBT;
IA←MAPORD[ID];
VPR←LENDV[IA,IB];
IF ¬PVMAP[VPR]∧ABS LLEV[IA,IB] ≠ RLEV-1 THEN
BEGIN "LP1"
BAU←BAUS;
INCOVS←BAUS←VL←0;
_ Get line ends + line, SV, and CV I.D.s;
BA0: NDP←IB;
NEWLP←IA;
INS←RAY←CH←RAYCNT←0;
IC←PLMAP[IA,1-IB];
NLSCM←NEWLSC←(IC+1)%2;
NDSCM←NDSC←IC LAND 1;
PLND←NEWSV←LVOPP(IC);
NSV ← NEXTSV(NEWSV,1);
VSC←LVERCO[NEWSV];
DTRC(":BA0:"QC(IA)QC(IB)QC(VPR)QC(NEWLP)QC(NDP)
QC(IC)QC(NLSCM)QC(NDSCM)QC(NEWSV)QC(VSC));
_ MAPREC cont - initialization and pre-orbit scan;
_ In the case of a backing-up ray go and check
if there is an intersection consequence vertex.;
IF BAU THEN GO BAAU;
_ If trying to creat an INCOV, we can skip testing
and preprocessing;
IF INCOV←(LLEV[IA,IB] MIN 0) THEN GO BA1;
_ Check that the c.v. has not already been mapped;
LOOP(IG,1,PVER,1) IF PVMAP[IG]=VSC THEN
BEGIN "B"
BULEVS←RLEV-1-
(LLEV[IA,1-IB] MAX ABS VLEV[IG]);
DTRC("C.V. CONTRAD."QC(BULEVS));
GO BU
END "B";
_ Not backup case. Make sure we have a whole line;
BA2: IF TSTB(NEWLSC,UNIT) THEN
BEGIN "D"
DTRC("RAY - TRY FUSION");
GO FUS
END "D";
_ we do: pre-orbit scan. If scene vertex is
incovs, we can mark it and start processing;
VL←PREORB;
IF VL=-2 THEN GO NFUS;
_ Check line length. If it is in a ||-class
branch on wrong length;
IAA←LENCLA(NEWLP,NEWLSC,0,0);
IF IAA=-2 THEN
BEGIN "E"
DTRC("SHORT - TRY FUSION?");
IF ¬RUL THEN DONE ELSE GO NINC
END "E";
_ MAPREC cont - get and check MODIF code, attempt fusion;
IF IAA=1 THEN
BEGIN "F"
DTRC("LONG - BACK UP?");
IF ¬RUL THEN DONE ELSE
NINC: IF ¬INCOVS THEN IF VL∨IAA=1 THEN
GO NFUS ELSE GO FUS ELSE
BEGIN "G"
DELREC(0);
DTRC("F-INCOV");
GO BU
END "G"
END "F";
_ Find vertex modification code (MODIF).;
RECON;
IF ¬RUL∧MODIF∧RLEV≥(IF FTSW THEN 3 ELSE 4)
THEN DONE;
VEMOD←MODIF LSH 2;
_ If we can do nothing with the vertex,try fusion.;
IF (MODIF LAND '200000000000∧IAA≠-1)∨
MODIF LAND '400000000000 THEN IF INCOVS THEN
BEGIN "H"
DTRC("INCOV NO GOOD");
DELREC(0);
DONE
END "H" ELSE GO FUS;
GO TO BA1;
_ Backing up - try fusion;
BAAU: DTRC("BAU ON");
BAU←0;
FUS: IF ¬VL∧(DEADLN[IA]∨¬(LEDG2[IA] LAND TFUSE))∧
FUSE(IC,IA,IB) THEN GO BA0 ELSE
BEGIN "J";
_ No fusion. Check for an intersection
consequence vertex. If none, nothing else
to do but leave as a ray.;
NFUS: INCOV←-1;
_ MAPREC cont - start of orbiting code - test INCOVs;
IF LLEV[IA,IB]≥0 THEN
BEGIN "ZZ"
LLEV[IA,IB]←-RLEV;
MPORDS[RLEV]←ID;
MAPIS[RLEV]←MAPIS[RLEV-1];
DTRC("BACK RAY"QC(RLEV));
RLEV←RLEV+1;
QTRC(CL&"Recursive branch,"
&" new level = "&
CVS(RLEV)&CL);
END "ZZ";
END "J";
_ Treat next prototype line around current vertex.;
BA1: NEWLP←LENDP[NEWLP,NDP];
IF NEWLP=IA THEN GO ON1;
NDP←-(LENDV[NEWLP,0]≠VPR);
NVP←LENDV[NEWLP,1-NDP];
IF ¬INCOV THEN GO TO MO;
IF LLEV[NEWLP,NDP]≥0 THEN GO BA1;
_ The other line is backing up.;
IF ¬DEADLN[IA]∧¬DEADLN[NEWLP]∧(LEDG2[IA] LAND TINCOV)
∧(LEDG2[NEWLP] LAND TINCOV) THEN GO TO BA1;
DTRC("TRY INTERSECTION");
IG←LVOPP(IC);
N1←PLMAP[NEWLP,1-NDP];
IF ¬N1 THEN
BEGIN DTRC("OTHER END NOT MAPPED");GO L3;END;
V2←LVOPP(N1);
V1←KARN(XLCOR[IC],YLCOR[IC],XLCOR[IG],YLCOR[IG],
XLCOR[N1],YLCOR[N1],XLCOR[V2],YLCOR[V2],1);
IG ← N1;
_ test for bad intersection;
L4: IF ¬V1∨IP1=1∨IP2=1∨IP1=-1∧R1<5.∨IP2=-1∧R2<5. THEN
BEGIN "L"
BULEVS←RLEV-1-(LLEV[NEWLP,1-NDP]
MAX LLEV[IA,1-IB]);
DTRC("-FAULT"QC(BULEVS));
GO L3
END "L";
N1 ← IF TSTB(NLSCM,UNIT) THEN 0 ELSE IP1;
N2 ← IF TSTB("(V2+1)%2",UNIT) THEN 0 ELSE IP2;
_ MAPREC cont - Intersection seems OK. Create the new vertex and lines;
_ Use uncertainty to adjust intersection if
necessary to satisfy length class;
IF UNCER THEN
BEGIN "M"
DTRC("F-INC-LEN");
L3: LEDG2[IA]←LEDG2[IA] LOR TINCOV;
LEDG2[NEWLP]←LEDG2[NEWLP] LOR TINCOV;
GO BU
END "M";
LLEVO[NEWLP,NDP]←LLEV[NEWLP,NDP];
LLEVO[IA,IB]←LLEV[IA,IB];
INSLEV[IA]←INSLEV[NEWLP]←LLEV[NEWLP,NDP]←
LLEV[IA,IB]←RLEV;
IAA←(IG+1)%2;
V2←IFREEV;
ICV0←PVMAP[NVP];
MAKLIN(IAA,NEWLP,NDP,IG,0,X,Y,LVOPP(IG));
IF N2<0 THEN SETB(IFR,CUT);
ICV0←LVERCO[IC];
MAKLIN(NEWLSC,IA,IB,IC,V2,0,0,PLND);
IF N1<0 THEN SETB(IFR,CUT);
INCOVS←1;
IF MAPTRC LAND 1 THEN UPPDAL(MAPTRC LAND 2);
_ Note that MAPORD-entry is not needed here.
Now continue with this created vertex
at the same recursive level.;
GO BA0;
MO: IF ¬INS THEN
BEGIN "N"
_ There is no insertion at this position, so
find mapping information for next
scene-line.;
MO1: NEWSV←NEXTSV(NEWSV,1);
NEWLSC←(NEWSV+1)%2;
NDSC←1-(NEWSV LAND 1);
NVSC←LVERCO[LVOPP(NEWSV)];
IF INS THEN GO L1
END "N";
_ MAPREC cont - process MODIF bits and test ray;
_ See if current scene-line should be
used, preceded by an insertion, or skipped.;
MOBITS←BITS(VEMOD,34,35);
VEMOD←VEMOD LSH 2;
INS←0;
QTRC(CL&"BASE="&CVS(IA)&" NEWLP="&CVS(NEWLP)&
" NEWSV="&CVS(NEWSV)&" INS="&CVS(INS));
CASE MOBITS OF
BEGIN
QTRC(" USE LINE");
BEGIN
QTRC(" INSERT LINE");
INS←1;
GO L1;
END;
BEGIN QTRC(" DELETE LINE");GO MO;END;
END;
_ Check that this scene-line has no contradictory use.;
LOOP(IG,1,PLIN,1)
IF IG≠NEWLP THEN
LOOP(IDL,0,1,1)
IF(PLMAP[IG,IDL]+1)%2=NEWLSC THEN
BEGIN "O"
DTRC("CONTR. USE"QC(NEWLP)QC(NEWLSC));
VL←1;
GO OU0
END "O";
_ Also check that the ray does not deviate drastically
from the general direction of its parallelity-class.
If it does, back up if ray is mapped at the other end
otherwise replace it by an inserted ray. Save LLEV for
full original lines, mapped at the other end.;
X←PARARG[PARCLA[NEWLP]];
IF X>-0.5∧ ANGDIF(ANGARG[NEWLSC],X)>RMAP THEN
BEGIN "P"
DTRC("F-ANGLE");
IF (PLMAP[NEWLP,1-NDP]+1)%2≠NEWLSC∧RUL THEN
INS←1 ELSE
BEGIN VL←1; GO OU0 END
END "P";
_ MAPREC cont - line insertion tests and map new line;
L1: ICN←PLMAP[NEWLP,1-NDP];
LMAP←(ICN+1)%2;
DTRC(":L1:"QC(LMAP));
IF LMAP THEN
IF LMAP=NEWLSC∧¬INS THEN
BEGIN "LMB"
IF ¬INCOVS THEN LLEVO[NEWLP,NDP]
←LLEV[NEWLP,NDP];
END "LMB" ELSE
IF ¬(INS∧LMAP='4000) THEN
IF ¬(IF INS∨LMAP='4000 THEN
FUSABL(IF INS THEN ICN ELSE NEWSV
,-INS,PVMAP[NVP],VSC)
ELSE FUSABL(1,1,LVOPP(ICN)
,LVOPP(NEWSV))) THEN
BEGIN "Q";
QTRC(CL&"///-test failed");
OU0: DTRC(":OU0:");
IF DELREC(0) THEN GO OU;
BAU←1;
IF INCOVS THEN GO BU ELSE GO BA0
END "Q";
_ At this point the other end is either unmapped
or the two mappings are identical or seem to
satisfy a ///-relationship.;
L2: CH←1;
RAY ← RAY+1;
IF ¬INS THEN RAYCNT←RAYCNT+1;
IF ¬LMAP THEN
BEGIN "R";
_ No mapping at other end. Just enter
(possibly insert) ray (or enter token,
if direction is not given).;
WE←PARARG[PARCLA[NEWLP]];
IF ¬INS THEN
BEGIN "RA"
PLMAP[NEWLP,NDP]←NEWSV;
SETB(NEWLSC,MAPPED+ONEND);
QTRC("MAP SCENE RAY"QC(NEWSV)QC(NEWLSC));
END "RA" ELSE
IF WE=-1. THEN
BEGIN "RB"
PLMAP[NEWLP,NDP]←'7777;
QTRC("ENTER TOKEN");
END "RB" ELSE BEGIN "S"
_ MAPREC cont - Insert new ray and find closest collinear active line.;
_ NOTE that here would be the logical place
to check incov:s for the new ray. However,
I predict that cases of intersection
faults will be rare enough to bias the
trade-off in favour of saving the check
until rays are backing up.;
_ Insert the ray, physically? If so, also mark
it as backing up.;
PLMAP[NEWLP,NDP]←2*IFREEL-1;
DTRC("INSERTING RAY"QC(IFREEL)QC(RAY)
QC(RAYS));
GA ← AMOD(WE-ANGARG[NLSCM]-180.
*NDSCM+720.,360.);
DA ← WE-180.*(GA≥180.∧RAY≤RAYS∨RAY>RAYS∧
GA≤180.);
GA←LENARG[PARCLA[NEWLP],CONDIV(NEWLP+AD0),
LENCAT[NEWLP]];
IF ¬GA THEN GA←5.0;
X2←XVCOR[VSC];
X1←X2+GA*COSD(DA);
Y2←YVCOR[VSC];
Y1←Y2+GA*SIND(DA);
LNY←IFREEL;
LINSET(VSC,0,0.,0.,X1,Y1,1002,0);
SETB(LNY,MAPPED+INSERT+UNIT);
_ find collinear line;
WE←900000.;
IAA←0;
LOOP(V1,1,MAXNOL,1)
IF LNCRE1≤LCREDE[V1] LAND
'400000007777≤LNCRE2
∧V1≠LNY
∧ANGLIN(LNY,V1)<RMAP THEN
BEGIN "T" REAL X,Y,L1,L2;
V2←2*V1-1;
L1←(X2-XLCOR[V2])↑2+(Y2-YLCOR[V2])↑2;
L2←(X2-XLCOR[V2+1])↑2+(Y2-YLCOR[V2+1])↑2;
IF L1<L2 THEN V2←V2+1;
REKOP(X2+0.4*(X2-X1),Y2+0.4*(Y2-Y1)
,XLCOR[V2],YLCOR[V2],RWIC,DA);
V2←LVOPP(V2);
X←XLCOR[V2];
Y←YLCOR[V2];
DA←(X1-X)↑2+(Y1-Y)↑2;
_ MAPREC cont - insert and map full lines;
IF INREK(X1,Y1)∧INREK(X,Y)∧DA<WE∧
DA*2.0<(L1 MAX L2) THEN
BEGIN IAA←V2;WE←DA;END;
END "T";
LINK[2*LNY]←IAA;
_ NOTE: The other line is not linked up, in
order not to complicate existing links in
the scene. So such links must be zero-ed
before such rays are deleted.;
LLEV[NEWLP,1-NDP]←IF IAA THEN 0 ELSE -RLEV
END "S";
LLEV[NEWLP,NDP]←RLEV;
_ The ray will partake in future mappings if
the other end is unmapped and the ray is
physical.;
IG ← PLMAP[NEWLP,NDP];
IF IG≠'7777 THEN
BEGIN "Z"
MAPI←MAPI+1;
MAPORD[MAPI]←NEWLP;
IF IG=NEWSV∧LCRL(NEWLSC)≠1002 THEN
MLCR(NEWLSC,1001)
END "Z";
END "R" ELSE BEGIN "U"
_ There is an entry at the other end. If
same line, just update PLMAP, otherwise
enter and insert a compound line to
replace (temporarily) the other ray.
It will replace the current ray only if
the ray is physical.;
X1←Y1←X2←Y2←0.;
IF LMAP≠'4000∧LMAP=NEWLSC∧¬INS THEN
BEGIN "UA"
PLMAP[NEWLP,NDP]←NEWSV;
QTRC("MAP SCENE LINE "QC(NEWSV)QC(NEWLSC));
LINCHK(NEWLSC);
END "UA" ELSE BEGIN "V"
INTEGER V1, V2;
_ MAPREC cont - end of insertion, update tables;
_ Note that MAPORD-entry is not needed here.;
PLMAP[NEWLP,NDP]←2*IFREEL-1;
QTRC("INSERTING LINE"QC(IFREEL));
PLMAPO[NEWLP,1-NDP]←ICN;
INSLEV[NEWLP]←RLEV;
IF LMAP≠'4000 THEN MLCR(LMAP,1003);
PLMAP[NEWLP,1-NDP]←2*IFREEL;
LLEVO[NEWLP,NDP]←LLEV[NEWLP,NDP];
IAA←LMAP≠'4000∧¬TSTB(LMAP,UNIT);
V1 ← NEWSV;
V2 ← ICN;
IF ¬INS∧¬IAA THEN V2←LVOPP(NEWSV);
IF INS∧IAA THEN V1←LVOPP(ICN);
IF V1≠'7777 THEN
BEGIN X1←XLCOR[V1]; Y1←YLCOR[V1]; END;
IF V2≠'7777 THEN
BEGIN X2←XLCOR[V2]; Y2←YLCOR[V2]; END;
IF ¬INS THEN MLCR(NEWLSC,1003);
PLMAPO[NEWLP,NDP]←IF INS THEN 0 ELSE NEWSV;
IFR ← IFREEL;
LINSET(VSC,PVMAP[NVP],X1,Y1,X2,Y2,1002,0);
SETB(IFR,"MAPPED+INSERT+LINE+
(IF IAA∧EXTNDV(ICN)∨-INS∧ EXTNDV(NEWSV)
THEN CUT ELSE 0)");
IF ¬INS THEN
BEGIN "VB"
V1 ← LEDG1[NEWLSC];
IF ¬(V1 LAND INSERT)∨V1 LAND ONEND THEN
BEGIN "VC"
SETB(IFR,ONEND);
IF ¬(V1 LAND INSERT)∨V1 LAND COLLIN
THEN SETB(IFR,COLLIN);
END "VC";
END "VB";
IF LMAP≠'4000 THEN
BEGIN "VD"
V1 ← LEDG1[LMAP];
IF ¬(V1 LAND INSERT)∨V1 LAND ONEND THEN
BEGIN "VE"
IF ¬TSTB(IFR,ONEND) THEN
SETB(IFR,ONEND) ELSE
BEGIN "VF"
SETB(IFR,TWOND);
RESET(IFR,ONEND);
END "VF";
IF ¬(V1 LAND INSERT)∨V1 LAND COLLIN
THEN SETB(IFR,COLLIN);
END "VE";
END "VD";
_ MAPREC cont - test line and finish orbit, LF consistency check;
DTRC(" "QCO(LEDG1[IFR]));
END "V";
LLEV[NEWLP,NDP]←RLEV;
_ Check length of new line if other end is mapped.;
IAA←LENCLA(NEWLP,PLMAP[NEWLP,NDP]
,PLMAP[NEWLP,1-NDP],1);
IF IAA=-2∨IAA=1 THEN
BEGIN
QTRC("F-LENGTH"QC(NEWLP));
GO OU0;
END;
END "U";
_ Take next line at current prototype vertex.;
IF ¬INS∧MAPTRC LAND 1 THEN UPPDAL(MAPTRC LAND 2);
GO BA1;
ON1: IF INCOV∧LLEV[IA,IB]=1-RLEV THEN
BEGIN
MPORD←2;
PUSHDD;
GO RULS;
END;
IF CH THEN
BEGIN "AA"
IF ¬RAYCNT THEN
BEGIN QTRC("Bare"&CL); GO OU0; END;
_ Test l.f. consistency for completed lines.
Backup if test fails, Otherwise update;
IG←0;
IF PVMAP[LENDV[IA,1-IB]] THEN LINCHK(NLSCM);
PLMAP[IA,IB]←PLND;
IF ¬LFCHCK THEN
BEGIN "CC"
QTRC(CL&"L.f.-check failed");
INSLEV[IA]←INSLEV[IA]-IG;
IF ¬INSLEV[IA] THEN PLMAP[IA,IB]←0;
GO OU0
END "CC";
_ MAPREC cont - update arrays and finish this level, end of main loop;
LLEV[IA,IB]←RLEV;
PVMAP[VPR]←VSC;
CLEVER(VSC,1007,0);
WEIGHV(VSC,XVCOR[VSC],YVCOR[VSC],RL);
LOOP(IG,1,PLIN,1)
IF LLEV[IG,0]=RLEV∨LLEV[IG,1]=RLEV THEN
PARUP(IG);
IF MAPTRC LAND 4 THEN
UPPDAL((MAPTRC LAND '10)*
(1-2*(MAPTRC LAND 1)));
VLEV[VPR]←IF INCOVS THEN -RLEV ELSE RLEV;
MPORDS[RLEV]←ID;
MAPIS[RLEV]←MAPI;
PUSHDD;
RLEV←RLEV+1;
QTRC(CL&"Recursive branch, new level = "&
CVS(RLEV)QCO(LEDG1[NLSCM])&CL);
MPORD ← 1-(RLEV>3);
PROGRESS ← TRUE;
GO RULS;
END "AA"
END "LP1"
END "A";
_ * * * * * CENTRAL LOOP ENDS * * * * *;
_ if F-mappings just finished, return for C-mappings;
IF ¬RUL THEN
BEGIN "DD"
RUL←1;
QTRC(CL&"C-mappings"&CL);
MPORD←2;
GO RULS
END "DD";
_ mapping finished, did we get anything ?;
IF ¬PROGRESS∨¬PARCHK THEN BEGIN SDTRC("NO PARTIAL"); GO BU END;
_ When we get here, we have a consistent partial mapping.
Exit if complete. Otherwise, if it is the best so far
then memorize it and back up to see if we can do better.;
SQTRC(CL&"Partial completion evaluation: ");
_ MAPREC cont - score mapping, test for completeness, save best partial;
_ First classify the elements into evaluation categories.;
CLEVA;
_ Now check if this mapping is a new maximum, and if so then save it.
If the mapping is a complete, we then exit, otherwise continue.;
SCORE;
PROGRESS ← FALSE;
IF MAPTRC LAND '20 THEN
BEGIN
OUTSTR(CL&"PARTIAL MAP - PROT:"&PNAME[PROT]&CL);
UPPDAL((MAPTRC LAND '40)*(1-2*(MAPTRC LAND 5)));
END;
IF INSUF THEN BEGIN SQTRC(CL&"Insufficient mapping"&CL); GO BU END;
IF ¬CMPL∧(SCO≤PARTS[CMPIND,0] LAND '777777777) THEN
BEGIN SQTRC("Not maximum partial"&CL); GO BU END;
_ We have a new maximal mapping. Save it in PARTS.;
CONH ← CONF;
SQTRC(CL&"Maximum partial"&CL);
IRET←0;
PARTS[CMPIND,0]←(PROT LSH 3 LOR (1+CMPL)) LSH 27 LOR SCO;
IC ← 1+MAXPLS%3;
LOOP(IG,1,IC,1) PARTS[CMPIND,IG]←0;
_ Delete copied insertions for previously best partial.;
LOOP(IG,1,MAXNOL,1)
BEGIN
N1←LCRL(IG);
IF N1=1004∨CMPL=-1∧N1=1005 THEN LINDL(IG,0);
END;
_ While saving current best partial, copy inserted lines at
LCREDE=1004.;
LOOP(IG,1,PLIN,1)
BEGIN "EE" INTEGER N3;
V1←PLMAP[IG,0];
V2←PLMAP[IG,1];
N1←V1 MAX V2;
_ MAPREC cont. - finish saving partial, backup code;
IF N1∧N1≠'7777∧LCRV(N1)=1002 THEN
IF CMPL=-1 THEN
BEGIN "BB"
N1←(N1+1)%2;
LCREDE[N1]←LCREDE[N1]+2;
END "BB" ELSE BEGIN "FF"
IF V1 THEN V1←2*IFREEL-(V1 LAND 1);
IF V2 THEN V2←2*IFREEL-(V2 LAND 1);
N2←N1+(N1 LAND 1)-1;
N3←LVOPP(N2);
LINSET(LVERCO[N2],LVERCO[N3],XLCOR[N2]
,YLCOR[N2],XLCOR[N3],YLCOR[N3],1004,0);
END "FF";
IC←(IG+2)%3;
PARTS[CMPIND,IC]←PARTS[CMPIND,IC]
LOR (((IF V1 THEN V1 ELSE V2) LAND '1777)
LOR (IF V1∧V2∨¬N1 THEN 0 ELSE
IF V1 THEN '2000 ELSE '4000))
LSH (12*(3*IC-IG))
END "EE";
_ Mapping is saved. See whether it is complete or not,
and branch accordingly.;
IF ¬(CMPL+1) THEN BEGIN IRET←1; GO OU END;
BU: _ Backup (BULEVS+1) recursive level(s).;
IF RLEV-BULEVS≤3 THEN GO OU;
QTRC(CL&"Backup: "QC(RLEV)QC(BULEVS));
WHILE BULEVS≥0 DO
BEGIN "GG"
RLEV←RLEV-1;
IF DELREC(1) THEN GO OU;
BULEVS←BULEVS-1
END "GG";
BULEVS←0;
_ Treat next elemental mapping, or try again with the same one,
depending on DELREC-decisions.;
GO RULS;
_ MAPREC cont. - clean up scene and return;
OU: IF IRET≠1 THEN SQTRC(CL&"Recursion exhausted - ");
CONF ← CONH;
IF CMPL THEN IRET←1;
CASE IRET+1 OF
BEGIN "HH"
SQTRC("Insufficient mapping"&CL);
SQTRC(CL&"Partial mapping"&CL);
SQTRC(CL&"Complete mapping"&CL)
END "HH";
_ Before returning, restore the scene and clean up.;
_ NOTE: We might later decide to have a scheme for direct
elimination of "1003-lines", rather than relying on CLUPSC
for their removal.;
LOOP(IA,1,MAXNOL,1)
BEGIN "II"
WHILE (IB←LCRL(IA))=1003∨IB=1007 DO REVIVE(IA);
IF IB=1001 THEN REVIVE(IA) ELSE IF IB=1002 THEN LINDL(IA,0)
END "II";
LNCRE2←LNCS2;
LNCRE0←LNCS1;
RETURN(IRET)
END "MAPREC";
END "MAPS2";